home *** CD-ROM | disk | FTP | other *** search
/ PC-Blue - MS DOS Public Domain Library / PC-Blue MS-DOS Public Domain Library - NYACC.iso / vol247 / rpn.bas < prev    next >
Encoding:
BASIC Source File  |  1986-12-01  |  10.4 KB  |  333 lines
  1. 1 REM --- RPN: PROGRAMMABLE RPN CALCULATOR
  2. 2 REM          WRITTEN BY FRANK LAROSA
  3. 3 REM          SEARCHLIGHT BBS (516) 724-0971
  4. 4 REM
  5. 5 REM  WRITTEN FOR IBM-PC MICROSOFT BASIC COMPILER
  6. 6 REM  MAY ALSO BE RUN UNDER INTERPRETED BASIC
  7. 7 REM
  8. 10 CLEAR:DEFINT A-D,N,I,P:LC=LOG(10):EE=LOG(1)
  9. 12 X=0:N1=0:Q=0:B=0:A=0:I=0:FX=4:FX$=STRING$(15-FX,"#")+"."+STRING$(FX,"#")
  10. 14 DEF FNR(X,Y)=INT(X*10^Y+.5)/10^Y
  11. 20 DIM S(4),A%(10),L%(50),P(1000),R(1000),K(300):AP=0
  12. 30 C$="RCIGTOSTOSTILBLRCLGTIGSBGSICONSUMPRDFIXROUDSZ"
  13. 40 C$=C$+"ENTADDSUBMPYDIVEXPABSCHS1/XLNXLOGALGALNSINCOSTAN"
  14. 50 C$=C$+"ASNACSATNRNDENDINTFRCPI PRXRTNRLDRLUEXCX=YX#YX<Y"
  15. 60 C$=C$+"X=0X#0X<0INPPRSNOPSQUSQRCLXCLSCLR":N=0:M$="LGIRSQXDF?"
  16. 65 ON ERROR GOTO 1400
  17. 70 CLS:PRINT:PRINT "RPN Programmable Calculator v1.4 by Frank LaRosa, 1/84   IBM version 9/85"
  18. 80 PRINT:PRINT "Enter ? for help.":PRINT:OL=15:GOTO 500
  19. 100 REM
  20. 102 REM   EXECUTE
  21. 104 MD=0:IF Q=0 THEN Q=1
  22. 105 PRINT:FL=0:IF K1$<>"" THEN OPEN "O",1,K1$:PRINT "Outputting to file: ";K1$:FL=1
  23. 106 IF Q=1 THEN 108:ELSE IF P(Q-1)<OL+1 AND P(Q-2)>OL THEN Q=Q+1
  24. 108 N1=Q:GOTO 112
  25. 110 N1=N1+1:IF MD=1 THEN RETURN
  26. 111 IF INKEY$=CHR$(27) THEN PRINT:PRINT "Break in";N1:RETURN
  27. 112 A=P(N1):ON A GOTO 130,154,136,142,150,122,160,164,174,180,390,400,410,420,430,184,188,194,198,202,206,212,216,220,224,228
  28. 113 IF A=0 THEN RETURN
  29. 114 ON A-26 GOTO 232,236,240,244,248,252,258,264,268,272,276,280,284,287,292,300,308,316,322,330
  30. 116 ON A-46 GOTO 336,342,348,354,360,366,372,376,380,440,445,450
  31. 118 RETURN
  32. 120 REM RCL
  33. 122 N1=N1+1:B=P(N1):X=R(B)
  34. 124 S(4)=S(3):S(3)=S(2)
  35. 126 S(2)=S(1):S(1)=X:GOTO 110 
  36. 128 REM RCI
  37. 130 N1=N1+1:B=P(N1):IF R(B)>-1 AND R(B)<501 THEN 132
  38. 131 PRINT "Range error in";N:RETURN
  39. 132 X=R(R(B)):GOTO 124
  40. 134 REM STO
  41. 136 N1=N1+1
  42. 138 R(P(N1))=S(1):GOTO 110 
  43. 140 REM STI
  44. 142 N1=N1+1
  45. 144 B=R(P(N1)):IF B<0 OR B>500 THEN 131
  46. 146 R(B)=S(1):GOTO 110 
  47. 148 REM LBL
  48. 150 N1=N1+1:GOTO 110 
  49. 152 REM GTO
  50. 154 B=P(N1+1):IF B>50 THEN 155 ELSE IF L%(B)<>0 THEN 156
  51. 155 PRINT "Branch error in";N-1:RETURN
  52. 156 N1=L%(B):MD=2:GOTO 112 
  53. 158 REM GTI
  54. 160 B=R(P(N1+1)):IF L%(B)<>0 THEN 156:ELSE GOTO 155
  55. 162 REM GSB
  56. 164 IF AP<10 THEN 168
  57. 166 PRINT "Too many GSB statements in";N1:RETURN
  58. 168 B=P(N1+1):IF L%(B)=0 THEN 155
  59. 170 AP=AP+1:A%(AP)=N1+2:GOTO 156 
  60. 172 REM GSI
  61. 174 IF AP>=4 THEN 166 
  62. 176 B=R(P(N1+1)):IF L%(B)=0 THEN 155:ELSE GOTO 170 
  63. 178 REM CON
  64. 180 N1=N1+2:X=CVS(MKI$(P(N1-1))+MKI$(P(N1))):GOTO 124
  65. 182 REM ENT
  66. 184 X=S(1):GOTO 124 
  67. 186 REM ADD
  68. 188 S(1)=S(1)+S(2)
  69. 190 S(2)=S(3):S(3)=S(4):GOTO 110 
  70. 192 REM SUB
  71. 194 S(1)=S(2)-S(1):GOTO 190 
  72. 196 REM MPY
  73. 198 S(1)=S(1)*S(2):GOTO 190 
  74. 200 REM DIV
  75. 202 S(1)=S(2)/S(1):GOTO 190 
  76. 204 REM EXP
  77. 206 IF S(2)<0 AND S(1)<1 THEN PRINT "Math error in";N1:RETURN
  78. 208 S(1)=S(2)^S(1):GOTO 190
  79. 210 REM ABS
  80. 212 S(1)=ABS(S(1)):GOTO 110 
  81. 214 REM CHS
  82. 216 S(1)=-S(1):GOTO 110 
  83. 218 REM 1/X
  84. 220 S(1)=1/S(1):GOTO 110 
  85. 222 REM LNX
  86. 224 S(1)=LOG(S(1)):GOTO 110 
  87. 226 REM LOG
  88. 228 S(1)=LOG(S(1))/LC:GOTO 110 
  89. 230 REM ALG
  90. 232 S(1)=10^S(1):GOTO 110
  91. 234 REM ALN
  92. 236 S(1)=EXP(S(1)):GOTO 110 
  93. 238 REM SIN
  94. 240 S(1)=SIN(S(1)):GOTO 110 
  95. 242 REM COS
  96. 244 S(1)=COS(S(1)):GOTO 110 
  97. 246 REM TAN
  98. 248 S(1)=TAN(S(1)):GOTO 110 
  99. 250 REM ASN
  100. 252 X=S(1)
  101. 254 S(1)=ATN(X/SQR(-X*X+1)):GOTO 110 
  102. 256 REM ACS
  103. 258 X=S(1)
  104. 260 S(1)=-ATN(X/SQR(-X*X+1))+1.5708:GOTO 110 
  105. 262 REM ATN
  106. 264 S(1)=ATN(S(1)):GOTO 110 
  107. 266 REM RND
  108. 268 X=RND(0):GOTO 124 
  109. 270 REM R/S
  110. 272 PRINT:PRINT "END in step";N1:RETURN
  111. 274 REM INT
  112. 276 S(1)=INT(S(1)):GOTO 110 
  113. 278 REM FRC
  114. 280 S(1)=S(1)-INT(S(1)):GOTO 110 
  115. 282 REM PI
  116. 284 X=3.14159:GOTO 124 
  117. 286 REM PRX
  118. 287 IF FL THEN PRINT #1,"--> ";:PRINT #1,USING FX$;S(1):GOTO 110
  119. 288 PRINT "--> ";:PRINT USING FX$;S(1):GOTO 110 
  120. 290 REM RTN
  121. 292 IF AP>0 THEN 296 
  122. 294 PRINT "RTN without GSB in step";N1:RETURN
  123. 296 MD=2:N1=A%(AP):AP=AP-1:IF N1>N THEN RETURN:ELSE 112
  124. 298 REM RLD
  125. 300 X=S(1)
  126. 302 S(1)=S(2):S(2)=S(3):S(3)=S(4)
  127. 304 S(4)=X:GOTO 110 
  128. 306 REM RLU
  129. 308 X=S(4)
  130. 310 S(4)=S(3):S(3)=S(2):S(2)=S(1)
  131. 312 S(1)=X:GOTO 110 
  132. 314 REM EXC
  133. 316 X=S(1):S(1)=S(2)
  134. 318 S(2)=X:GOTO 110 
  135. 320 REM X=Y
  136. 322 IF S(1)=S(2) THEN 110 
  137. 324 N1=N1+1:IF P(N1)<OL+1 THEN N1=N1+1
  138. 326 GOTO 110 
  139. 328 REM X#Y
  140. 330 IF S(1)<>S(2) THEN 110 
  141. 332 GOTO 324 
  142. 334 REM X<Y
  143. 336 IF S(1)<S(2) THEN 110 
  144. 338 GOTO 324 
  145. 340 REM X=0
  146. 342 IF S(1)=0 THEN 110 
  147. 344 GOTO 324 
  148. 346 REM X#0
  149. 348 IF S(1)<>0 THEN 110 
  150. 350 GOTO 324 
  151. 352 REM X<0
  152. 354 IF S(1)<0 THEN 110 
  153. 356 GOTO 324 
  154. 358 REM INP
  155. 360 LINE INPUT "* ";X$
  156. 362 X=VAL(X$):GOTO 124 
  157. 364 REM PRS
  158. 366 FOR I=1 TO 4:IF FL THEN PRINT #1,USING FX$;S(I);:ELSE PRINT USING FX$;S(I);
  159. 368 NEXT:IF FL THEN PRINT #1,: ELSE PRINT
  160. 369 GOTO 110
  161. 370 REM NOP
  162. 372 GOTO 110 
  163. 374 REM SQU
  164. 376 S(1)=S(1)*S(1):GOTO 110
  165. 378 REM SQR
  166. 380 IF S(1)>=0 THEN S(1)=SQR(S(1)):GOTO 110
  167. 382 PRINT "Negative SQR in";N1:RETURN
  168. 390 REM SUM
  169. 392 N1=N1+1:B=P(N1)
  170. 394 R(B)=R(B)+S(1):GOTO 110
  171. 400 REM PRD
  172. 402 N1=N1+1:B=P(N1)
  173. 404 R(B)=R(B)*S(1):GOTO 110
  174. 410 REM FIX
  175. 412 N1=N1+1:FX=P(N1):FX$=STRING$(15-FX,"#")+"."+STRING$(FX,"#")
  176. 414 GOTO 110
  177. 420 REM ROU
  178. 422 N1=N1+1:B=P(N1)
  179. 424 S(1)=FNR(S(1),B):GOTO 110
  180. 430 REM DSZ
  181. 432 N1=N1+1:B=P(N1)
  182. 434 R(B)=R(B)-1:IF R(B)<>0 THEN 110
  183. 436 N1=N1+1:IF P(N1)>OL THEN 110
  184. 438 N1=N1+1:GOTO 110
  185. 440 REM CLX
  186. 442 S(1)=0:GOTO 110
  187. 445 REM CLS
  188. 446 FOR I=1 TO 4:S(I)=0:NEXT:GOTO 110
  189. 450 REM CLR
  190. 452 FOR I=0 TO 500:R(I)=0:NEXT:GOTO 110
  191. 499 REM
  192. 500 Q=0:Q1=0:PRINT:PRINT "RPN>";:LINE INPUT K$:IF K$="" THEN 500
  193. 501 I=INSTR(K$," "):IF I>0 THEN K1$=MID$(K$,I+1) ELSE K1$=""
  194. 502 IF LEN(K$)>=2 AND INSTR(C$,LEFT$(K$,2))<>0 THEN 1300
  195. 504 IF INSTR("0123456789.-",LEFT$(K$,1))<>0 THEN K$="CON"+K$:GOTO 1300
  196. 510 I=INSTR(M$,LEFT$(K$,1)):IF I=0 THEN 552
  197. 520 Q=VAL(MID$(K$,2)):I1=INSTR(K$,","):IF I1<>0 THEN Q1=VAL(MID$(K$,I1+1)):ELSE Q1=0
  198. 530 ON I GOSUB 835,104,580,990,1100,560,561,1210,555,1330
  199. 550 CLOSE 1:FL=0:GOTO 500
  200. 552 PRINT "Unknown statement or command":GOTO 500
  201. 555 PRINT:IF K1$="" THEN K1$="*.*"
  202. 557 FILES K1$:RETURN
  203. 560 PRINT "Program terminated - Returning to DOS":END
  204. 561 IF LEN(K$)>1 THEN 565
  205. 562 PRINT "X =";S(1),"Y =";S(2),
  206. 564 PRINT "Z =";S(3),"T =";S(4):GOTO 500
  207. 565 IF Q>1000 THEN PRINT "Out of range":GOTO 500
  208. 566 PRINT "R(";RIGHT$(STR$(Q),LEN(STR$(Q))-1);") =";R(Q):GOTO 500
  209. 570 REM
  210. 580 REM  INPUT & ASSEMBLE LINES
  211. 590 REM
  212. 600 IM=0:MD=0:IF Q=0 THEN N=N+1:GOTO 610
  213. 602 Q1=Q:IM=1:IF Q1=1 THEN 604:ELSE IF P(Q-1)>OL OR (P(Q-2)<OL+1 OR P(Q-2)=0) THEN 604
  214. 603 Q1=Q1+1
  215. 604 B1=1:N2=N:N=Q1
  216. 610 REM
  217. 620 LOCATE 24,1:PRINT:LOCATE 23,1:PRINT USING "###";N;:PRINT " - ";:LINE INPUT A$
  218. 625 IF A$="" THEN 770
  219. 640 IF LEN(A$)<3 THEN A$=A$+STRING$(3-LEN(A$),32)
  220. 650 R=INSTR(C$,LEFT$(A$,3)):IF R<>0 THEN 670 
  221. 660 PRINT "Syntax Error":GOTO 769
  222. 670 R=(R-1)/3+1:IF R<>INT(R) THEN 660 
  223. 680 IF R>OL THEN 760 
  224. 690 IF LEN(A$)>3 THEN 710 
  225. 700 PRINT "Missing Operand":GOTO 769
  226. 710 Q=VAL(MID$(A$,4)):IF R=14 THEN 750:ELSE IF R=10 THEN 742
  227. 715 IF R=5 AND Q>50 THEN 740
  228. 720 IF R<5 AND Q<501 AND Q>-1 THEN 750 
  229. 730 IF R<11 AND Q<51 AND Q>-1 THEN 750
  230. 732 IF R<OL+1 AND Q<1001 AND Q>-1 THEN 750
  231. 740 PRINT "Operand out of range":GOTO 769
  232. 742 H$=MKS$(Q):Q3=CVI(LEFT$(H$,2)):Q2=CVI(RIGHT$(H$,2))
  233. 744 IF IM=0 THEN P(N)=R:P(N+1)=Q3:P(N+2)=Q2:GOTO 765
  234. 746 K(B1)=R:K(B1+1)=Q3:K(B1+2)=Q2:B1=B1+3:GOTO 765
  235. 750 IF IM=0 THEN P(N)=R:P(N+1)=Q:GOTO 765
  236. 755 K(B1)=R:K(B1+1)=Q:B1=B1+2:GOTO 765
  237. 760 IF IM=0 THEN P(N)=R:GOTO 765
  238. 762 K(B1)=R:B1=B1+1
  239. 765 IF MD=0 THEN LOCATE 23,1:PRINT USING "###:  ";N;:PRINT TAB(7);
  240. 766 IF MD=0 THEN PRINT MID$(C$,(R-1)*3+1,3);TAB(12);
  241. 767 IF MD=0 THEN IF R<OL+1 THEN PRINT Q:ELSE PRINT
  242. 768 N=N+1:IF R<OL+1 THEN N=N+1:IF R=10 THEN N=N+1
  243. 769 IF MD=0 THEN 620:ELSE RETURN
  244. 770 IF IM=0 THEN N=N-1:GOTO 800
  245. 771 B1=B1-1:N=N2:FOR I=N TO Q1 STEP -1
  246. 772 P(I+B1)=P(I):NEXT I
  247. 774 FOR I=0 TO B1-1:P(Q1+I)=K(I+1):NEXT I
  248. 775 N=N+B1:GOTO 800
  249. 800 GOSUB 920:RETURN
  250. 810 REM
  251. 820 REM  LIST
  252. 830 REM
  253. 835 IF Q=0 THEN Q=1
  254. 840 PRINT:IF Q=1 THEN 845
  255. 842 IF P(Q-1)<=OL AND P(Q-2)>OL THEN Q=Q+1
  256. 845 IF N=0 THEN RETURN
  257. 847 FL=0:IF K1$<>"" THEN OPEN "O",1,K1$:PRINT "Listing to file: ";K1$:FL=1
  258. 850 I$=INKEY$:FOR D=Q TO N
  259. 860 IF FL THEN PRINT #1,USING "###:  ";D;:PRINT #1,TAB(7);
  260. 865 IF FL=0 THEN PRINT USING "###:  ";D;:PRINT TAB(7);
  261. 870 T=P(D):I=0
  262. 880 IF T<OL+1 THEN Q=P(D+1):D=D+1:I=1
  263. 885 IF T=10 THEN Q1=P(D+1):D=D+1:I=2
  264. 890 IF FL THEN PRINT #1,MID$(C$,(T-1)*3+1,3);TAB(12);
  265. 895 IF FL=0 THEN PRINT MID$(C$,(T-1)*3+1,3);TAB(12);
  266. 897 IF FL=0 THEN 901
  267. 900 IF I=1 THEN PRINT #1,Q:GOTO 902: ELSE IF I=2 THEN PRINT #1,CVS(MKI$(Q)+MKI$(Q1)):GOTO 902:ELSE PRINT #1,:GOTO 902
  268. 901 IF I=1 THEN PRINT Q: ELSE IF I=2 THEN PRINT CVS(MKI$(Q)+MKI$(Q1)):ELSE PRINT
  269. 902 I$=INKEY$:IF I$="" THEN 910
  270. 904 IF I$=CHR$(27) THEN D=N:GOTO 910
  271. 906 I$=INKEY$:IF I$="" THEN 906
  272. 908 IF I$=CHR$(27) THEN D=N
  273. 910 NEXT:CLOSE 1:RETURN
  274. 920 REM  COMPILE LABELS
  275. 930 FOR I=1 TO 50:L%(I)=0:NEXT
  276. 940 FOR I=1 TO N:A=P(I):IF A=5 THEN 950
  277. 945 IF A<=OL THEN I=I+1:IF A=10 THEN I=I+1
  278. 948 GOTO 970
  279. 950 K=P(I+1):L%(K)=I+2:I=I+1
  280. 970 NEXT:RETURN
  281. 980 REM
  282. 990 REM  RECALL ASSEMBLED PROGRAM
  283. 1000 REM
  284. 1005 IF K1$<>"" THEN F$=K1$:GOTO 1015
  285. 1010 LINE INPUT "INPUT FILE: ";F$:IF F$="" THEN RETURN
  286. 1015 OPEN "R",1,F$+".RPN",1:N=0
  287. 1020 FIELD 1, 1 AS D$:FOR J=1 TO LOF(1)
  288. 1030 GET 1:A=ASC(D$):IF A=0 THEN 1070
  289. 1040 N=N+1:P(N)=A:IF A>OL THEN 1068
  290. 1050 IF A=10 THEN 1062
  291. 1052 N=N+1:GET 1:U$=D$:GET 1:U$=U$+D$
  292. 1054 P(N)=CVI(U$):J=J+2
  293. 1060 GOTO 1068
  294. 1062 N=N+1:GET 1:U$=D$:GET 1:U$=U$+D$:P(N)=CVI(U$)
  295. 1064 N=N+1:GET 1:U$=D$:GET 1:U$=U$+D$:P(N)=CVI(U$)
  296. 1066 J=J+4
  297. 1068 NEXT J
  298. 1070 CLOSE:PRINT:PRINT USING "#### Lines";N
  299. 1080 GOSUB 920:RETURN
  300. 1090 REM
  301. 1100 REM  SAVE CODE
  302. 1110 REM
  303. 1115 IF K1$<>"" THEN F$=K1$:GOTO 1150
  304. 1120 LINE INPUT "OUTPUT FILE: ";F$:IF F$="" THEN RETURN
  305. 1150 OPEN "R",1,F$+".RPN",1:FIELD 1, 1 AS D$
  306. 1160 FOR I=1 TO N:A=P(I):LSET D$=CHR$(A):PUT 1
  307. 1165 IF A=10 THEN 1192
  308. 1170 IF A>OL THEN 1200 
  309. 1180 I=I+1:G=P(I):U$=MKI$(G)
  310. 1190 LSET D$=LEFT$(U$,1):PUT 1:LSET D$=RIGHT$(U$,1):PUT 1:GOTO 1200
  311. 1192 U$=MKI$(P(I+1))+MKI$(P(I+2)):I=I+2
  312. 1194 FOR J=1 TO 4:LSET D$=MID$(U$,J,1):PUT 1
  313. 1196 NEXT
  314. 1200 NEXT:CLOSE:RETURN
  315. 1209 REM
  316. 1210 REM  DELETE
  317. 1211 REM
  318. 1220 IF Q1=0 THEN Q1=Q
  319. 1222 IF P(Q1)<=OL THEN Q1=Q1+1:IF P(Q1-1)=10 THEN Q1=Q1+1
  320. 1224 B=Q1-Q+1
  321. 1230 FOR I=Q1+1 TO N
  322. 1235 P(I-B)=P(I):NEXT:N=N-B
  323. 1240 GOTO 800
  324. 1300 A$=K$:MD=1:IM=0:B2=N:N=N+1:P(N)=0:GOSUB 640:N=B2:N1=N+1
  325. 1310 IF P(N1)<>0 THEN GOSUB 112
  326. 1320 GOTO 500
  327. 1330 REM HELP
  328. 1340 PRINT:FOR I=0 TO 57
  329. 1350 PRINT MID$(C$,3*I+1,3);"  ";:IF POS(0)=60 THEN PRINT
  330. 1360 NEXT:PRINT:PRINT:PRINT "Insert  List  Go  Delete  Save  Recall  Files  Xamine  ?  Quit":RETURN
  331. 1400 REM ERROR TRAP
  332. 1410 PRINT:PRINT "Input Error":RESUME 500
  333.